home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / JTools / Janim / animbrush.f < prev    next >
Encoding:
FORTH Source  |  1991-12-04  |  5.8 KB  |  316 lines
  1. \ ANIMBrush support for JForth
  2. \
  3. \ Author: Martin Kees  10/14/90
  4. \ Copyright: 1990 Martin Kees
  5. \ Freely distributable to the JForth Community
  6.  
  7. \ MOD: PLB 10/20/90 1- in abr.ADVANCE for PINGPONG
  8. \ MOD: MCK 11/5/90  fixed abr.GET.FRAME
  9. \ MOD: MCK 11/5/90  $abr.LOAD  missing @ after $anim-file
  10. \ MOD: MCK 11/5/90  $abr.SAVE added
  11. \ MOD: MCK 2/9/91   change 'animbr' to 'abr' in names
  12. \ MOD: MCK 2/11/91  ANIM-ERROR support
  13. \ MOD: MCK 2/11/91  Removed abr.advance from abr.blit and abr.transblit
  14. \ MOD: PLB 10/25/91 Cosmetic changes.
  15. \ MOD: PLB 11/15/91 Rewrote error handling.
  16. \ 00001 PLB 11/27/91 Make ABR.ADVANCE handle change of mode at ends.
  17. \ 00002 PLB 12/4/91 Added ABR.LAST.FRAME?
  18.  
  19. anew TASK-ANIMBRUSH
  20.  
  21. : ABR.CHECK ( animbr -- , abort if bad )
  22.     ..@ abr_key
  23.     abr_valid_key -
  24.     abort" Invalid or Empty AnimBrush"
  25. ;
  26.  
  27. : ABR.FREE ( animbr -- , free all parts of animbrush )
  28.     dup ..@ abr_key
  29.     abr_valid_key =
  30.     IF  >r  ( save on RS )
  31.         r@ pic.free
  32.         r@ .. abr_DELTAlist freelist?
  33.         r@ ..@ abr_ytable free.ytable
  34.         r> sizeof() animbrush erase
  35.     ELSE
  36.         drop
  37.     THEN
  38. ;
  39.  
  40. : $ABR.LOAD? { $filename animbr  --- error? }
  41.     animbr ABR.free
  42.     $filename $anim.scan? ?goto.error
  43. \
  44. \ validate ANIMBRUSH format
  45.     anim-operation @ 5 =
  46.     anim-interleave @ 1 = \ !!! for ANIMBRUSH
  47. true \     anim-bits @ 2 =       \ !!! for ANIMBRUSH
  48.     and and not
  49.     IF
  50.         $anim-file @ $type
  51.         ." : AnimBrush-file is not of correct format!" cr
  52.         anim-operation @ ." OP: " .
  53.         anim-interleave @ ." Interleave: " .
  54.         anim-bits @ ." Bits: " . cr
  55.         GOTO.ERROR
  56.     THEN
  57. \
  58.     MEMF_PUBLIC deltacount @ cells allocblock
  59.     dup
  60.     IF deltaptr !
  61.     ELSE
  62.         ." No memory for Delta Pointers!" cr GOTO.ERROR
  63.     THEN
  64. \
  65. \ load initial picture
  66.     ilbm.init
  67.     ' anim.handler is ilbm.other.handler
  68.     $anim-file @ animbr $pic.load?
  69.     IF
  70.         ." Not able to load ILBM" cr goto.error
  71.     THEN
  72.     ' 2drop is ilbm.other.handler
  73. \
  74. \ setup animbrush
  75.     $anim-file freevar
  76.     abr_valid_key animbr ..! abr_key
  77.     deltaptr @ animbr ..! abr_deltalist
  78.     deltaptr off
  79.     deltacount @ animbr ..! abr_cels
  80.     deltacount off
  81. \
  82.     abr_FORWARD animbr ..! abr_direction
  83.     abr_LOOP    animbr ..! abr_flags
  84.     0 animbr ..! abr_atdelta
  85. \
  86.     animbr anim.alloc.ytable? ?goto.error
  87. \
  88.     FALSE
  89.     exit
  90. \
  91. ERROR:
  92.     deltaptr freevar
  93.     $anim-file freevar
  94.     animbr abr.free
  95.     TRUE
  96. ;
  97.  
  98.  
  99. : ABR.LOAD? ( animbursh <filename> -- error? )
  100.     fileword swap $ABR.load?
  101. ;
  102.  
  103. : ABR.ADVANCE { animbr | delta bmap ytab --- }
  104.     animbr ..@ abr_deltalist
  105.     animbr ..@ abr_atdelta cells + @ -> delta
  106.     animbr ..@ abr_ytable -> ytab
  107.     animbr dup ..@ pic_bitmap -> bmap
  108. \
  109.     pic.get.depth 0
  110.     DO
  111.         delta i cells + @ ?dup
  112.         IF
  113.             delta +
  114.             i bmap bmplane[] @ >rel
  115.             ytab
  116.             decode_xorvkplane
  117.         THEN
  118.     LOOP
  119. \
  120.     animbr ..@ abr_atdelta
  121.     animbr ..@ abr_direction +
  122.     animbr ..@ abr_flags
  123.     CASE
  124.         dup abr_Loop and
  125.         ?OF
  126.             dup animbr ..@ abr_cels >=   \ if at end?, goto 0 , 00001
  127.             IF drop 0
  128.             ELSE dup -1 <= \ 00001
  129.                 IF
  130.                     drop
  131.                     animbr ..@ abr_cels 1-
  132.                 THEN
  133.             THEN
  134.             animbr ..! abr_atdelta
  135.         ENDOF
  136. \
  137.         dup abr_PingPong and
  138.         ?OF
  139. \ turn around if at either end, don't repeat end. 00001
  140.             dup animbr ..@ abr_cels 1- >= \ on last one?, go backward
  141.             IF 
  142.                 drop animbr ..@ abr_cels 2-  \ second from end 
  143.                 abr_BACKWARD animbr ..! abr_direction
  144.             ELSE dup -1 <=
  145.                 IF
  146.                     drop 0
  147.                     abr_FORWARD animbr ..! abr_direction
  148.                 THEN
  149.             THEN
  150.             animbr ..! abr_atdelta
  151.         ENDOF
  152.     ENDCASE
  153. ;
  154.  
  155. : ABR.GET.FRAME ( animbr --- current-frame )
  156.     dup>r
  157.     ..@ abr_atdelta
  158.     r@ ..@ abr_direction
  159.     abr_FORWARD =
  160.     IF rdrop exit
  161.     ELSE
  162.         1+ dup r> ..@ abr_cels =
  163.         IF drop 0
  164.         THEN
  165.     THEN
  166. ;
  167.  
  168. : ABR.REVERSE ( animbr --- , reverse direction of advance )
  169.     dup>r
  170.     ..@ abr_cels 1-
  171.     0
  172.     r@ ..@ abr_direction
  173.     dup negate r@ ..! abr_direction
  174.     abr_BACKWARD =
  175.     IF swap
  176.     THEN
  177. \
  178.     r@ ..@ abr_atdelta =
  179.     IF r@ ..! abr_atdelta
  180.     ELSE
  181.         drop
  182.         r@ ..@ abr_direction
  183.         r@ ..@ abr_atdelta
  184.         +
  185.         r@ ..! abr_atdelta
  186.     THEN
  187.     rdrop
  188. ;
  189.  
  190. : ABR.STATS ( animbrush --- )
  191.     dup>r
  192.     ABR.check
  193.     cr
  194.     ." Size: " r@ pic.get.wh swap . ." X " . cr
  195.     ." Planes: " r@ pic.get.depth . cr
  196.     ." Cells: "  r@ ..@ abr_cels . cr
  197.     ." Direction: " r@ ..@ abr_direction
  198.     CASE
  199.         abr_FORWARD OF ." Forward " cr
  200.             ENDOF
  201.         abr_BACKWARD
  202.             OF ." Backward " cr
  203.             ENDOF
  204.         ." NOT defined" cr
  205.     ENDCASE
  206.     ." Mode: " r@ ..@ abr_flags
  207.     CASE
  208.         abr_loop OF ." Looping " cr
  209.             ENDOF
  210.         abr_pingpong
  211.             OF ." Ping Pong" cr
  212.             ENDOF
  213.         ." NOT defined" cr
  214.     ENDCASE
  215.     ." Current Frame: " r@ ABR.get.frame . cr
  216.     ." Next Delta: " r@ ..@ abr_atdelta . cr
  217.     rdrop
  218. ;
  219.  
  220. : ABR.BLIT ( x y animbr --- )     \ Blits
  221.     pic.blit
  222. ;
  223.  
  224. : ABR.TRANS.BLIT ( x y animbr --- ) \ Blits transparently
  225.     dup>r
  226.     ABR.check
  227.     r@ ..@ pic_shadow 0=
  228.     IF
  229.         r@ pic.alloc.shadow?
  230.         IF
  231.             ." No shadow memory" cr
  232.             rdrop exit
  233.         THEN
  234.     THEN
  235.     r@ pic.cast.shadow
  236.     r> pic.trans.blit
  237. ;
  238.  
  239. : ABR.GOTO.FRAME ( frame animbr --- )
  240.     dup>r
  241.     ABR.check
  242.     dup 0 r@ ..@ abr_cels 1-
  243.     within?
  244.     IF
  245.         BEGIN
  246.             dup r@ ABR.get.frame
  247.             =
  248.         WHILE-NOT
  249.             r@ ABR.advance
  250.         REPEAT
  251.         drop
  252.     ELSE
  253.         ." Frame:" . ."  is Not in range! "
  254.     THEN
  255.     rdrop
  256. ;
  257.  
  258.  
  259. : ABR.SAVE.DELTAS ( animbr -- error? )
  260.     anim.save.deltas?
  261. ;
  262.  
  263. : $ABR.SAVE? { $filename animbr --- error? }
  264.     animbr abr.check
  265. \
  266.     0 animbr abr.goto.frame
  267. \
  268. \ setup DPaint chunk
  269.     3 anim-dpan ..! dp_code
  270.     animbr ..@ abr_cels  anim-dpan ..! dp_frames
  271.     0  anim-dpan ..! dp_rate
  272.     0  anim-dpan ..! dp_mode
  273.     animbr ..@ abr_cels  anim-dpan ..! dp_dur
  274. \
  275.     new $filename $iff.open? 0= ?goto.error
  276. \
  277. \ this leaves position on stack
  278.     'ANIM' iff.begin.form?     IF drop goto.error THEN
  279. \
  280. \ write initial image
  281.     animbr ..@ pic_bitmap
  282.     animbr ..@ pic_ctable  animbr ..@ pic_num_colors
  283.     0
  284.     anim-dpan
  285.     ilbm.write.ilbm+camg+dpan? IF drop ?goto.error THEN
  286. \
  287. \ specific to ANIMBRUSHES
  288.     anim-header sizeof() ANHD erase
  289.     1 anim-header ..! ah_interleave
  290.     2 anim-header ..! ah_bits
  291. \
  292. \ save all deltas
  293.     animbr anim.save.deltas? IF drop goto.error THEN
  294. \
  295.     iff.end.form? ?goto.error
  296.     iff.close
  297. \
  298.     FALSE
  299.     exit
  300. ERROR:
  301.     iff.close
  302.     TRUE
  303. ;
  304.  
  305.  
  306. : ABR.SAVE? ( animbr <filename> --- )
  307.     fileword swap $ABR.save?
  308. ;
  309.  
  310.  
  311. : ABR.LAST.FRAME? ( abr -- flag ) \ 00002
  312.     dup ..@ abr_cels 1-
  313.     swap ..@ abr_atdelta =
  314. ;
  315.  
  316.